{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit ItXmlizer;

interface

uses
  Classes, SysUtils, TestCore, ItCommon, SelectQuestion, InputQuestion,
  MatchQuestion, OrderQuestion, ClassifyQuestion, MiscUtils, Pad, Profile,
  Script, CommonModifiers;

type
  TXmlTestEventSink = class
  protected
    procedure BeginElement(const ElementName: String); virtual; abstract;
    procedure EndElement; virtual; abstract;
    procedure AddAttribute(const AttributeName, AttributeValue: String); virtual; abstract;
    procedure CreateFile(const FileName: String); virtual; abstract;
    function GetFileStream: TStream; virtual; abstract;
    procedure CloseFile; virtual; abstract;
  end;

  TTestXmlizer = class
  private
    FSink: TXmlTestEventSink;
    FNextFileIndex: Int64;
  public
    constructor Create(Sink: TXmlTestEventSink);

    procedure be(const ElementName: String);
    procedure ee;
    procedure aa(const AttributeName, AttributeValue: String);

    procedure DoContent(Pad: TPad);
    procedure DoTextPadObject(Obj: TTextPadObject);
    procedure DoLineFeedPadObject(Obj: TLineFeedPadObject);
    procedure DoGraphicPadObject(Obj: TGraphicPadObject);

    procedure DoModifiers(List: TModifierList);
    procedure DoModifier(Modifier: TModifier);
    procedure DoSetNegativeChoiceContentModifier(Modifier: TSetNegativeChoiceContentModifier);
    procedure DoSetEvaluationModelModifier(Modifier: TSetEvaluationModelModifier);
    procedure DoSetWeightModifier(Modifier: TSetWeightModifier);
    procedure DoScriptModifier(Modifier: TScriptModifier);

    procedure DoProfile(Profile: TProfile);
    procedure DoConfiguration(cf: TWorkConfiguration);
    procedure DoResultPolicy(rp: TResultPolicy);
    procedure DoMarkScale(ms: TMarkScale);

    property NextFileIndex: Int64 read FNextFileIndex write FNextFileIndex;
  end;

implementation

type
  TXmlQuestionSpecifier = record
    QuestionClass: TQuestionClass;
    XmlType: String;
  end;

const
  XmlQuestionSpecifiers: array [0..4] of TXmlQuestionSpecifier = (
    (QuestionClass: TSelectQuestion;   XmlType: VAL_QUESTION_TYPE_SELECT),
    (QuestionClass: TInputQuestion;    XmlType: VAL_QUESTION_TYPE_INPUT),
    (QuestionClass: TMatchQuestion;    XmlType: VAL_QUESTION_TYPE_MATCH),
    (QuestionClass: TOrderQuestion;    XmlType: VAL_QUESTION_TYPE_ORDER),
    (QuestionClass: TClassifyQuestion; XmlType: VAL_QUESTION_TYPE_CLASSIFY)
  );

procedure TextPadObjectHandler(Obj: TPadObject; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoTextPadObject(Obj as TTextPadObject);
end;

procedure LineFeedPadObjectHandler(Obj: TPadObject; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoLineFeedPadObject(Obj as TLineFeedPadObject);
end;

procedure GraphicPadObjectHandler(Obj: TPadObject; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoGraphicPadObject(Obj as TGraphicPadObject);
end;

type
  TPadObjectHandler = procedure(Obj: TPadObject; Xmlizer: TTestXmlizer);

  TXmlPadObjectSpecifier = record
    PadObjectClass: TPadObjectClass;
    Handler: TPadObjectHandler;
  end;

const
  XmlPadObjectSpecifiers: array [0..2] of TXmlPadObjectSpecifier = (
    (PadObjectClass: TTextPadObject;     Handler: TextPadObjectHandler),
    (PadObjectClass: TLineFeedPadObject; Handler: LineFeedPadObjectHandler),
    (PadObjectClass: TGraphicPadObject;  Handler: GraphicPadObjectHandler)
  );

type
  TXmlImageSpecifier = record
    Format: String;
    Extension: String;
  end;

const
  XmlImageSpecifiers: array [0..1] of TXmlImageSpecifier = (
    (Format: 'PNG';  Extension: IT_IMAGE_PNG_EXTENSION),
    (Format: 'JPEG'; Extension: IT_IMAGE_JPG_EXTENSION)
  );

procedure NullModifierHandler(Modifier: TModifier; Xmlizer: TTestXmlizer);
begin
  { do nothing }
end;

procedure SetNegativeChoiceContentModifierHandler(Modifier: TModifier; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoSetNegativeChoiceContentModifier(Modifier as TSetNegativeChoiceContentModifier);
end;

procedure SetEvaluationModelModifierHandler(Modifier: TModifier; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoSetEvaluationModelModifier(Modifier as TSetEvaluationModelModifier);
end;

procedure SetWeightModifierHandler(Modifier: TModifier; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoSetWeightModifier(Modifier as TSetWeightModifier);
end;

procedure ScriptModifierHandler(Modifier: TModifier; Xmlizer: TTestXmlizer);
begin
  Xmlizer.DoScriptModifier(Modifier as TScriptModifier);
end;

type
  TModifierHandler = procedure(Modifier: TModifier; Xmlizer: TTestXmlizer);

  TXmlModifierSpecifier = record
    ModifierClass: TModifierClass;
    XmlType: String;
    Handler: TModifierHandler;
  end;

const
  XmlModifierSpecifiers: array [0..6] of TXmlModifierSpecifier = (
    (ModifierClass: TSuppressSingleChoiceHintModifier; XmlType: VAL_MODIFIER_TYPE_SUPPRESS_SINGLE_CHOICE_HINT; Handler: NullModifierHandler),
    (ModifierClass: TAddNegativeChoiceModifier;        XmlType: VAL_MODIFIER_TYPE_ADD_NEGATIVE_CHOICE;         Handler: NullModifierHandler),
    (ModifierClass: TSetNegativeChoiceContentModifier; XmlType: VAL_MODIFIER_TYPE_SET_NEGATIVE_CHOICE_CONTENT; Handler: SetNegativeChoiceContentModifierHandler),
    (ModifierClass: TShuffleChoicesModifier;           XmlType: VAL_MODIFIER_TYPE_SHUFFLE_CHOICES;             Handler: NullModifierHandler),
    (ModifierClass: TSetEvaluationModelModifier;       XmlType: VAL_MODIFIER_TYPE_SET_EVALUATION_MODEL;        Handler: SetEvaluationModelModifierHandler),
    (ModifierClass: TSetWeightModifier;                XmlType: VAL_MODIFIER_TYPE_SET_WEIGHT;                  Handler: SetWeightModifierHandler),
    (ModifierClass: TScriptModifier;                   XmlType: VAL_MODIFIER_TYPE_SCRIPT;                      Handler: ScriptModifierHandler)
  );

function FindQuestionSpecifier(QuestionClass: TQuestionClass): TXmlQuestionSpecifier;
var
  i: Integer;
begin
  for i := Low(XmlQuestionSpecifiers) to High(XmlQuestionSpecifiers) do
    if XmlQuestionSpecifiers[i].QuestionClass = QuestionClass then
    begin
      Result := XmlQuestionSpecifiers[i];
      Exit;
    end;
  raise Exception.CreateFmt('Unknown question class: "%s".', [QuestionClass.ClassName]);
end;

function BooleanToXmlValue(b: Boolean): String;
begin
  if b then
    Result := VAL_TRUE
  else
    Result := VAL_FALSE;
end;

function FindPadObjectSpecifier(PadObjectClass: TPadObjectClass): TXmlPadObjectSpecifier;
var
  i: Integer;
begin
  for i := Low(XmlPadObjectSpecifiers) to High(XmlPadObjectSpecifiers) do
    if XmlPadObjectSpecifiers[i].PadObjectClass = PadObjectClass then
    begin
      Result := XmlPadObjectSpecifiers[i];
      Exit;
    end;
  raise Exception.CreateFmt('Unknown content class: "%s".', [PadObjectClass.ClassName]);
end;

function FindImageSpecifier(const ImageFormat: String): TXmlImageSpecifier;
var
  i: Integer;
begin
  for i := Low(XmlImageSpecifiers) to High(XmlImageSpecifiers) do
    if SameText(XmlImageSpecifiers[i].Format, ImageFormat) then
    begin
      Result := XmlImageSpecifiers[i];
      Exit;
    end;
  raise Exception.CreateFmt('Unknown image format: "%s".', [ImageFormat]);
end;

function SingleToXmlValue(v: Single): String;
begin
  Result := FormatFloat('0.0000', v);
end;

function IntToStrZeroSpecial(v: Integer; const ZeroString: String): String;
begin
  if v = 0 then
    Result := ZeroString
  else
    Result := IntToStr(v);
end;

function FindModifierSpecifier(ModifierClass: TModifierClass): TXmlModifierSpecifier;
var
  i: Integer;
begin
  for i := Low(XmlModifierSpecifiers) to High(XmlModifierSpecifiers) do
    if XmlModifierSpecifiers[i].ModifierClass = ModifierClass then
    begin
      Result := XmlModifierSpecifiers[i];
      Exit;
    end;
  raise Exception.CreateFmt('Unknown modifier class: "%s".', [ModifierClass.ClassName]);
end;

function LaxEvaluationToXml(LaxEvaluation: Boolean): String;
begin
  if LaxEvaluation then
    Result := VAL_EVALUATION_MODEL_TYPE_LAX
  else
    Result := VAL_EVALUATION_MODEL_TYPE_DICHOTOMIC;
end;

{ TTestXmlizer }

procedure TTestXmlizer.aa(const AttributeName, AttributeValue: String);
begin
  FSink.AddAttribute(AttributeName, AttributeValue);
end;

procedure TTestXmlizer.be(const ElementName: String);
begin
  FSink.BeginElement(ElementName);
end;

constructor TTestXmlizer.Create(Sink: TXmlTestEventSink);
begin
  inherited Create;
  FSink := Sink;
  FNextFileIndex := 1;
end;

procedure TTestXmlizer.DoConfiguration(cf: TWorkConfiguration);
begin
  be(ELEM_QUESTION_SELECTION);
  aa(ATTR_QUESTIONS_PER_SECTION, IntToStrZeroSpecial(cf.QuestionsPerSection, VAL_ALL));
  if cf.UseLabelFilter then
    aa(ATTR_LABEL_FILTER, cf.LabelFilter);
  aa(ATTR_SHUFFLE_QUESTIONS, BooleanToXmlValue(cf.ShuffleQuestions));
  ee;

  be(ELEM_SESSION_OPTIONS);
  aa(ATTR_DURATION_MINUTES, IntToStrZeroSpecial(cf.DurationMinutes, VAL_UNLIMITED));
  aa(ATTR_EDITABLE_ANSWERS, BooleanToXmlValue(cf.EditableAnswers));
  aa(ATTR_BROWSABLE_QUESTIONS, BooleanToXmlValue(cf.BrowsableQuestions));
  aa(ATTR_WEIGHT_CUES, BooleanToXmlValue(cf.WeightCues));
  ee;

  if not cf.EditableAnswers then
  begin
    be(ELEM_INSTANT_FEEDBACK);
    aa(ATTR_ANSWER_CORRECTNESS, BooleanToXmlValue(cf.InstantAnswerCorrectness));
    aa(ATTR_TOTAL_PERCENT_CORRECT, BooleanToXmlValue(cf.InstantTotalPercentCorrect));
    ee;
  end;
end;

procedure TTestXmlizer.DoContent(Pad: TPad);
var
  i: Integer;
  Obj: TPadObject;
begin
  be(ELEM_CONTENT);

  for i := 0 to Pad.ObjectCount-1 do
  begin
    Obj := Pad.Objects[i];
    FindPadObjectSpecifier(TPadObjectClass(Obj.ClassType)).Handler(Obj, Self);
  end;

  ee;
end;

procedure TTestXmlizer.DoGraphicPadObject(Obj: TGraphicPadObject);
var
  ImageFileName, SourceFileName: String;
begin
  ImageFileName := Format('%s/%d.%s', [IT_IMAGE_DIRECTORY_NAME, FNextFileIndex,
    FindImageSpecifier(Obj.ImageFormat).Extension]);
  FSink.CreateFile(ImageFileName);
  WriteStreamString(FSink.GetFileStream, Obj.ImageData);
  FSink.CloseFile;

  if Obj.SourceFormat <> '' then
  begin
    SourceFileName := Format('%s/%d.%s', [IT_IMAGE_DIRECTORY_NAME, FNextFileIndex,
      IT_SOURCE_DATA_FILE_EXTENSION]);
    FSink.CreateFile(SourceFileName);
    WriteStreamString(FSink.GetFileStream, Obj.SourceData);
    FSink.CloseFile;
  end;

  be(ELEM_IMG);
  aa(ATTR_SRC, ImageFileName);
  if Obj.SourceFormat <> '' then
  begin
    aa(ATTR_CLIPBOARD_FORMAT, Obj.SourceFormat);
    aa(ATTR_CLIPBOARD_DATA, SourceFileName);
  end;
  ee;

  Inc(FNextFileIndex);
end;

procedure TTestXmlizer.DoLineFeedPadObject(Obj: TLineFeedPadObject);
begin
  be(ELEM_BR);
  ee;
end;

procedure TTestXmlizer.DoMarkScale(ms: TMarkScale);
var
  i: Integer;
begin
  if ms.ItemCount > 0 then
  begin
    be(ELEM_MARK_SCALE);
    be(ELEM_MARKS);
    for i := 0 to ms.ItemCount-1 do
    begin
      be(ELEM_MARK);
      aa(ATTR_TITLE, ms.Marks[i]);
      aa(ATTR_LOWER_BOUND, SingleToXmlValue(ms.LowerBounds[i]));
      ee;
    end;
    ee;
    ee;
  end;
end;

procedure TTestXmlizer.DoModifier(Modifier: TModifier);
var
  Spec: TXmlModifierSpecifier;
begin
  be(ELEM_MODIFIER);
  Spec := FindModifierSpecifier(TModifierClass(Modifier.ClassType));
  aa(ATTR_TYPE, Spec.XmlType);
  Spec.Handler(Modifier, Self);
  ee;
end;

procedure TTestXmlizer.DoModifiers(List: TModifierList);
var
  i: Integer;
begin
  if List.Count > 0 then
  begin
    be(ELEM_MODIFIERS);
    for i := 0 to List.Count-1 do
      DoModifier(List[i]);
    ee;
  end;
end;

procedure TTestXmlizer.DoProfile(Profile: TProfile);
begin
  be(ELEM_PROFILE);
  aa(ATTR_TITLE, Profile.Title);

  DoConfiguration(Profile.Configuration);
  DoResultPolicy(Profile.ResultPolicy);
  DoMarkScale(Profile.MarkScale);
  DoModifiers(Profile.ModifierList);

  ee;
end;

procedure TTestXmlizer.DoResultPolicy(rp: TResultPolicy);
begin
  if rp.ResultsAvailable then
  begin
    be(ELEM_TEST_RESULTS);
    aa(ATTR_PERCENT_CORRECT, BooleanToXmlValue(rp.PercentCorrect));
    aa(ATTR_POINTS, BooleanToXmlValue(rp.Points));
    aa(ATTR_MARK, BooleanToXmlValue(rp.Mark));

    if rp.QuestionResultsAvailable then
    begin
      be(ELEM_QUESTION_RESULTS);
      aa(ATTR_PERCENT_CORRECT, BooleanToXmlValue(rp.QuestionPercentCorrect));
      aa(ATTR_POINTS, BooleanToXmlValue(rp.QuestionPoints));
      aa(ATTR_CORRECT_ANSWER, BooleanToXmlValue(rp.QuestionCorrectAnswer));
      ee;
    end;

    if rp.SectionResultsAvailable then
    begin
      be(ELEM_SECTION_RESULTS);
      aa(ATTR_PERCENT_CORRECT, BooleanToXmlValue(rp.SectionPercentCorrect));
      aa(ATTR_POINTS, BooleanToXmlValue(rp.SectionPoints));
      aa(ATTR_QUESTION_COUNT, BooleanToXmlValue(rp.SectionQuestionCount));
      aa(ATTR_QUESTION_LIST, BooleanToXmlValue(rp.SectionQuestionList));
      ee;
    end;

    ee;
  end;
end;

procedure TTestXmlizer.DoScriptModifier(Modifier: TScriptModifier);
var
  Script: TStrings;
  Line: String;
begin
  Script := TStringList.Create;
  try
    Modifier.GetScript(Script);
    for Line in Script do
    begin
      be(ELEM_SCRIPT);
      aa(ATTR_LINE, Line);
      ee;
    end;
  finally
    Script.Free;
  end;
end;

procedure TTestXmlizer.DoSetEvaluationModelModifier(
  Modifier: TSetEvaluationModelModifier);
var
  QuestionClass: TQuestionClass;
begin
  aa(ATTR_NEW_EVALUATION_MODEL, LaxEvaluationToXml(Modifier.LaxEvaluation));

  if Modifier.QuestionClasses.Count > 0 then
  begin
    be(ELEM_APPLY_TO);
    for QuestionClass in Modifier.QuestionClasses do
    begin
      be(ELEM_QUESTION_TYPE);
      aa(ATTR_VALUE, FindQuestionSpecifier(QuestionClass).XmlType);
      ee;
    end;
    ee;
  end;
end;

procedure TTestXmlizer.DoSetNegativeChoiceContentModifier(
  Modifier: TSetNegativeChoiceContentModifier);
var
  Content: TPad;
begin
  Content := TPad.Create;
  try
    Modifier.GetContent(Content);
    DoContent(Content);
  finally
    Content.Free;
  end;
end;

procedure TTestXmlizer.DoSetWeightModifier(Modifier: TSetWeightModifier);
begin
  aa(ATTR_NEW_WEIGHT, IntToStr(Modifier.NewWeight));
end;

procedure TTestXmlizer.DoTextPadObject(Obj: TTextPadObject);
begin
  be(ELEM_TEXT);
  aa(ATTR_VALUE, UTF8Encode(Obj.Text));
  ee;
end;

procedure TTestXmlizer.ee;
begin
  FSink.EndElement;
end;

end.
